home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / init.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  9.9 KB  |  391 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #define GEN
  11.  
  12. #include "hdr.h"
  13. #include "vars.h"
  14. #include "gvars.h"
  15. #include "libhdr.h"
  16. #include "segment.h"
  17. #include "slot.h"
  18. #include "ifile.h"
  19. #include "readprots.h"
  20. #include "setprots.h"
  21. #include "genprots.h"
  22. #include "miscprots.h"
  23. #include "smiscprots.h"
  24. #include "arithprots.h"
  25. #include "axqrprots.h"
  26. #include "initprots.h"
  27.  
  28. static Tuple precedes_map_new();
  29. static void init_predef_exceptions();
  30. static void init_predef_exception(int, int, int, char *);
  31.  
  32. /* These are defined here since type Segment not known in gvars.[ch] */
  33. Segment    CODE_SEGMENT, DATA_SEGMENT, DATA_SEGMENT_MAIN;
  34. Segment FIELD_TABLE, VARIANT_TABLE;
  35. Tuple units_in_compilation;
  36.  
  37. /* INITALIZATIONS AND FINALIZATION
  38.  * General initialization
  39.  */
  40.  
  41. void initialize_1()                                            /*;initialize_1*/
  42. {
  43.     /*
  44.      * Initializes global variables that are to be kept between the two
  45.      * phases of generation.
  46.      */
  47.  
  48.     int    i;
  49.  
  50.     /* initialize FIELD_TABLE and VARIANT_TABLE. These are data segments
  51.      * that are reset to be empty but are not reallocated for each unit
  52.      */
  53.     FIELD_TABLE = segment_new(SEGMENT_KIND_DATA, 0);
  54.     VARIANT_TABLE = segment_new(SEGMENT_KIND_DATA, 0);
  55.     /* tree maps */
  56.     ivalue_1 = int_fri(1); 
  57.     ivalue_10 = int_fri(10);
  58.     int_const_0 = int_const(0);
  59.     rat_value_10 = rat_fri(ivalue_1, ivalue_10);
  60.  
  61.     int_const_null_task = int_const(-1);
  62.  
  63.     /*initializations of variables used only by generator */
  64.     /* explicit_ref_0 is used to pass addresses to be filled in later, and
  65.      * corresponds to [0, 0] case in SETL version.
  66.      */
  67.     explicit_ref_0 = explicit_ref_new(0, 0);
  68.     global_reference_tuple = tup_new(0);
  69.  
  70.     N_SIDE(OPT_NODE) = FALSE;
  71.  
  72.     /* AXQ maps: */
  73.     CODE_SEGMENT_MAP = tup_new(0);
  74.     DATA_SEGMENT_MAP = tup_new(0);
  75.     /* Global variables */
  76.     EMAP = tup_new(0);
  77. #ifdef TBSN
  78.     PREDEF_UNITS       = [[], {}];
  79.     /* These are handled using EMAP in C version */
  80.     STATIC_DEPTH       = {
  81.     };
  82.     POSITION       = {
  83.     };
  84.     PATCHES       = {
  85.     };
  86.     EQUAL       = {
  87.     };
  88. #endif
  89.     CODE_PATCH_SET  = tup_new(0);
  90.     DATA_PATCH_SET  = tup_new(0);
  91.     PARAMETER_SET   = tup_new(0);
  92.     RELAY_SET       = tup_new(0);
  93. #ifdef TBSN
  94.     axqfiles_read   = {
  95.         '_MEMORY'    };
  96.     instruction_stack    = [];
  97.     deleted_instructions = 0;
  98.     BTIME        = 0;
  99.     optimizable_codes    = domain automat0 +/{
  100.         {x, y    }
  101. :
  102.     [x, y] in domain(automat1)+domain(automat2)};
  103. #endif
  104.     /*    Slots initialization */
  105.     /* INIT_SLOTS and MAX_INDEX are procedures in C version, defined at
  106.      * the end of this file
  107.      */
  108.     DATA_SLOTS = tup_new(0);
  109.     CODE_SLOTS = tup_new(0);
  110.     /*
  111.      * EXCEPTION_SLOTS = { ['CONSTRAINT_ERROR', 1],
  112.      *            ['NUMERIC_ERROR',    2],
  113.      *            ['PROGRAM_ERROR',    3],
  114.      *            ['STORAGE_ERROR',    4],
  115.      *            ['TASKING_ERROR',    5]
  116.      *            ['SYSTEM_ERROR',    6]
  117.      *            };
  118.      */
  119.     EXCEPTION_SLOTS = tup_new(5);
  120.     EXCEPTION_SLOTS[1] = (char *) slot_new(symbol_constraint_error, 1);
  121.     EXCEPTION_SLOTS[2] = (char *) slot_new(symbol_numeric_error, 2);
  122.     EXCEPTION_SLOTS[3] = (char *) slot_new(symbol_program_error, 3);
  123.     EXCEPTION_SLOTS[4] = (char *) slot_new(symbol_storage_error, 4);
  124.     EXCEPTION_SLOTS[5] = (char *) slot_new(symbol_tasking_error, 5);
  125.     if (!compiling_predef)  {
  126.         /* if not compiling predef, make room for predef slots */
  127.         EXCEPTION_SLOTS = tup_exp(EXCEPTION_SLOTS, 15);
  128.         init_predef_exceptions();
  129.     }
  130.  
  131.     PRECEDES_MAP = precedes_map_new();
  132.  
  133.     compilation_table = tup_new(num_predef_units);
  134.     for (i = 1; i <= num_predef_units; i++) compilation_table[i] = (char *) i;
  135.     late_instances    = tup_new(8);
  136.     late_instances[1] = strjoin("spSEQUENTIAL_IO", "");
  137.     late_instances[2] = strjoin("boSEQUENTIAL_IO", "");
  138.     late_instances[3] = strjoin("spDIRECT_IO", "");
  139.     late_instances[4] = strjoin("boDIRECT_IO", "");
  140.     late_instances[5] = strjoin("ssUNCHECKED_DEALLOCATION", "");
  141.     late_instances[6] = strjoin("suUNCHECKED_DEALLOCATION", "");
  142.     late_instances[7] = strjoin("ssUNCHECKED_CONVERSION", "");
  143.     late_instances[8] = strjoin("suUNCHECKED_CONVERSION", "");
  144.  
  145.     stubs_to_write = set_new(0);
  146.     units_in_compilation = tup_new(0);
  147.     /* integer arithmetic */
  148.     /* ADA_MIN_INTEGER and ADA_MAX_INTEGER are defined in adasem vars.c */
  149.  
  150.     /* 'standard' symbol table
  151.      * Warning : values are given for SETL only 
  152.      * IN CASE OF CHANGES IN THESE VALUES REPORT CHANGE INTO THE 
  153.      * BINDER (Initialization of idle_task data segment). 
  154.      */
  155. }
  156.  
  157. void initialize_2()                                            /*;initialize_2*/
  158. {
  159.     /*
  160.      * Initializations of file, of variables depending on the option string,
  161.      * and of variables that are to be reset between the two phases
  162.      */
  163.  
  164.     Axq    axq;
  165.     /* Variables */
  166.  
  167. #ifdef TBSL
  168.     STIME       = time;
  169. #endif
  170.     ada_line       = 0;
  171.     NB_INSTRUCTIONS = 0;
  172.     NB_STATEMENTS   = 0;
  173.  
  174.     /* tree map */
  175.  
  176.     if (!new_library) {
  177.         axq = (Axq) emalloct(sizeof(Axq_s), "axq");
  178.         load_library(axq);
  179.     }
  180. }
  181.  
  182. /* print_data_segment moved to segment.c */
  183.  
  184. /* TBSL: Note that INIT_SLOTS should be a procedure, as it is a read-only
  185.  * set
  186.  * It is referenced only by select_entry once initialized, as is the case
  187.  * also with MAX_INDEX.
  188.  */
  189. int init_slots(int kind)                                /*;init_slots*/
  190. {
  191.     int n;
  192.     if (compiling_predef) {
  193.         if (kind == SLOTS_DATA) n =  2;
  194.         else if (kind == SLOTS_CODE) n =  3;
  195.         else if (kind == SLOTS_EXCEPTION)  n = 5;
  196.         else chaos("init_slots bad kind");
  197.     }
  198.     else {
  199.         if (kind == SLOTS_DATA)
  200. #ifdef PREDEF_PC
  201.         n =  31;
  202. #else
  203.         n = 8;
  204. #endif
  205.         else if (kind == SLOTS_CODE)
  206. #ifdef PREDEF_PC
  207.         n =  35;
  208. #else
  209.         n = 11;
  210. #endif
  211.         else if (kind == SLOTS_EXCEPTION)  n =  15;
  212.         else chaos("init_slots bad kind");
  213.     }
  214.     return n;
  215. }
  216.  
  217. int max_index(int kind)                                            /*;max_index*/
  218. {
  219.     if (kind == SLOTS_DATA) return 255;
  220.     else if (kind == SLOTS_CODE) return 32767;
  221.     else if (kind == SLOTS_EXCEPTION) return 255;
  222.     chaos("max_slots bad kind");
  223.     return 0;
  224. }
  225.  
  226. static Tuple precedes_map_new()                            /*;precedes_map_new*/
  227. {
  228.     return (tup_new(0));
  229. }
  230.  
  231. Slot slot_new(Symbol sym, int number)                            /*;slot_new*/
  232. {
  233.     Slot s;
  234.     char    *sname;
  235.  
  236.     s = (Slot) emalloct(sizeof(Slot_s), "slot-new");
  237.     s->slot_seq = S_SEQ(sym);
  238.     s->slot_unit = S_UNIT(sym);
  239.     sname = ORIG_NAME(sym);
  240.     /* Make copy */
  241.     s->slot_name = (sname == (char *)0) ? (char *)0 : strjoin(sname, "");
  242.     s->slot_number = number;
  243.     return s;
  244. }
  245.  
  246. static void init_predef_exceptions()                /*;init_predef_exceptions*/
  247. {
  248.     /* the body of this procedure is obtained by examining the standard
  249.      * output when compiling predef!  Hopefully a more rational scheme
  250.      * of initialization will be provided in the future (after validation).
  251.      *    shields  11-5-85
  252.      */
  253.  
  254.     init_predef_exception(26, 1, 6, "SYSTEM_ERROR");
  255.     init_predef_exception(3, 2, 7, "STATUS_ERROR");
  256.     init_predef_exception(4, 2, 8, "MODE_ERROR");
  257.     init_predef_exception(5, 2, 9, "NAME_ERROR");
  258.     init_predef_exception(6, 2, 10, "USE_ERROR");
  259.     init_predef_exception(7, 2, 11, "DEVICE_ERROR");
  260.     init_predef_exception(8, 2, 12, "END_ERROR");
  261.     init_predef_exception(9, 2, 13, "DATA_ERROR");
  262.     init_predef_exception(10, 2, 14, "LAYOUT_ERROR");
  263.     init_predef_exception(58, 9, 15, "TIME_ERROR");
  264. }
  265.  
  266. static void init_predef_exception(int seq, int unt, int number, char *name)
  267.                                                     /*;init_predef_exception*/
  268. {
  269.     /* seq - sequence of symbol for exception 
  270.      * number - exception number assigned 
  271.      * name - exception name 
  272.      */
  273.  
  274.     Slot s;
  275.     s = (Slot) emalloct(sizeof(Slot_s), "init-predef-exception-slot");
  276.     s->slot_seq = seq;
  277.     s->slot_unit = unt;
  278.     s->slot_name = (name == (char *)0) ? (char *)0 : strjoin(name, "");
  279.     s->slot_number = number;
  280.     EXCEPTION_SLOTS[number] = (char *) s;
  281. }
  282.  
  283. void remove_slots(Tuple tup, int unit)                        /*;remove_slots*/
  284. {
  285.     int        i, n;
  286.     Slot    s;
  287.     /* go through the tuple (CODE_SLOTS or DATA_SLOTS) and remove slots that are
  288.      * attached to the obsolete unit.
  289.      */
  290.     n = tup_size(tup);
  291.     i = 1;
  292.     while (i <= n) {
  293.         s = (Slot) tup[i];
  294.         if (unit == s->slot_unit) {
  295.             tup[i] = tup[n];
  296.             n -= 1;
  297.         }
  298.         else {
  299.             i++;
  300.         }
  301.     }
  302.     tup[0] = (char *)n;
  303. }
  304.  
  305. void remove_interface(Tuple tup, int unit)                /*;remove_interface*/
  306. {
  307.     int        i, n;
  308.     int         unit_nbr;
  309.     /* go through the tuple interfaced_procedures and remove strings that are
  310.      * attached to the obsolete unit.
  311.      */
  312.     n = tup_size(tup);
  313.     i = 1;
  314.     while (i <= n) {
  315.         unit_nbr = (int) tup[i];
  316.         if (unit == unit_nbr) {
  317.             tup[i+1] = tup[n];
  318.             tup[i] = tup[n-1];
  319.             n -= 2;
  320.         }
  321.         else {
  322.             i += 2;
  323.         }
  324.     }
  325.     tup[0] = (char *)n;
  326. }
  327.  
  328. void private_exchange(Symbol package_name)                /*;private_exchange*/ 
  329. {
  330.     Fordeclared     fd1;
  331.     Forprivate_decls    fp1;
  332.     Private_declarations  pd;
  333.     Symbol s1, s2, sym;
  334.     char     *id;
  335.  
  336.     if (NATURE(package_name) == na_package_spec
  337.       || NATURE(package_name) == na_package) {
  338.         pd = (Private_declarations) private_decls(package_name);
  339.         FORPRIVATE_DECLS(s1, s2, pd, fp1);
  340.             private_decls_swap(s1, s2);
  341.         ENDFORPRIVATE_DECLS(fp1);
  342.  
  343.         /* And apply same to inner package specs.*/
  344.  
  345.         FORDECLARED(id, sym, DECLARED(package_name), fd1);
  346.             if (S_UNIT(sym) == S_UNIT(package_name)
  347.               && SCOPE_OF(sym) == package_name) {
  348.                 private_exchange(sym);
  349.             }
  350.         ENDFORDECLARED(fd1);
  351.     }
  352. }
  353.  
  354. void private_install(Symbol package_name)                     /*;private_install*/
  355. {
  356.     Fordeclared    fd1;
  357.     Forprivate_decls fp1;
  358.     Private_declarations  pd;
  359.     Symbol s1, s2;
  360.     int exists;
  361.     char     *id;
  362.  
  363.     /* Install full declarations for unit in context clause. To see if needed,
  364.      * scan priv part to see if currently visible entries contain private types.
  365.      */
  366.     if (NATURE(package_name) == na_package_spec
  367.       || NATURE(package_name) == na_package) {
  368.         pd = (Private_declarations) private_decls(package_name);
  369.         if (pd == (Private_declarations)0) return; /* Not assigned yet.*/
  370.  
  371.         exists = FALSE;
  372.         FORPRIVATE_DECLS(s1, s2, pd, fp1);
  373.             if (TYPE_OF(s1) == symbol_private 
  374.               || TYPE_OF(s1) == symbol_limited_private) {
  375.                 exists = TRUE;
  376.                 break;
  377.             }
  378.         ENDFORPRIVATE_DECLS(fp1);
  379.         if (exists) private_exchange(package_name);
  380.         /* else { */
  381.         /* Check recursively in inner packages. (The outer one may have no
  382.           * private part.
  383.           */
  384.         FORDECLARED(id, s1, DECLARED(package_name), fd1);
  385.             if (s1 != package_name)
  386.                 private_install(s1);
  387.         ENDFORDECLARED(fd1);
  388.         /*} */
  389.     }
  390. }
  391.